home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Diamond Collection / The Diamond Collection (Software Vault)(Digital Impact).ISO / cdr11 / ged2ex11.zip / GED2EX11.MAC < prev   
Text File  |  1995-02-21  |  28KB  |  760 lines
  1. '---------------------- Begin Macro -----------------------------
  2. ' ImportGEDCOM - Version 1.1b (Beta)
  3. '   (The 'focused' version will be the Beta Carotene version :-) :-)
  4. '
  5. ' (c) 1995 by Thomas Edward Thacker, Jr.
  6. '
  7. ' Reads a GEnealogical Data COMmunications (GEDCOM) file.
  8. ' GEDCOM is a proprietary EDI standard (c) by the LDS Church but
  9. '   permitted to be used as an industry standard.
  10. '
  11. '    This is part of an ongoing project I have to create a complete
  12. ' genealogy system using Microsoft Excel. I thought members of the
  13. ' soc.genealogy.computing newsgroup would benefit from receiving an
  14. ' early beta version of this piece of the effort for their evaluation
  15. ' and enjoyment. Enjoy.
  16. '
  17. ' Cover-myself-statement:
  18. '
  19. '   (With apologies, I include this to help the newsgroup deter unauthorized
  20. ' commercial exploitation of their archives. Fidonet's genealogy archives
  21. ' were thusly exploited despite their best effort to stop it.):
  22. '
  23. '    Anyone including this routine (or any piece thereof) in any commercial
  24. ' package in any way, shape, or form without express written agreement
  25. ' implies their agreement to a ten percent royalty of all gross revenues
  26. ' and recompense directly or indirectly derived from distribution of this
  27. ' product, with no allowable deductions whatsoever. This shall include but
  28. ' not be limited to shipping & handling, material, labor, donations, in any
  29. ' way shape or form. (That ought to deter them thar software pirates).
  30. '
  31. '
  32. ' Hardware - At Least a PC/386/486/585.99998245, MS-Dos 3.3+, 4MB+ RAM.
  33. ' Software - Microsoft Windows 3.0 or later
  34. '          - Microsoft Excel 5.0 for Windows with OLE extensions.
  35. '            (This *won't* work on Excel 4 or earlier)!
  36. ' Language - Microsoft Excel 5.0 Visual Basic Macro Language
  37. '
  38. ' Developed on a Gateway 2000 P5-60 Pentium,
  39. '   Tower Case, 28.8k Faxmodem,
  40. '   8MB Ram, 27MB Swap File, 540MB HD in 4 partitions,
  41. '   Free space = C:13,456kB, D:17,884kB, E:44,382kB, F:3,242kB
  42. '   Windows in C:\WINDOWS, temp in D:\TEMP
  43. '   MS-Dos 6.22, Windows for Workgroups 3.11, Excel 5.0a for Windows,
  44. '
  45. ' This has *not* been tested on a MAC. I don't know what changes would
  46. ' have to be made to make it MACable. The Excel version required must
  47. ' have Excel Visual Basic Macro Language and be able to support Multi
  48. ' Sheet Workbooks.
  49. '
  50. ' How to Load:
  51. ' (1) Edit the text to remove all E-mail headers up to and including
  52. '     the "---Begin Source---" line, and all E-mail text after the
  53. '     "---End Source---" line.
  54. ' (2) Start MS Excel 5.0a to receive the macro.
  55. ' (3) On the toolbar, select File, New to start a new spreadsheet.
  56. ' (4) Right-click on the Sheet Name (Should be 'Sheet1') to pull up
  57. '     the Sheet Menu. Select Insert, Module to create the macro page
  58. '     that will receive the source text.
  59. ' (5) Select the empty module sheet.
  60. ' (6) Select Insert File and give the name of the ASCII text file
  61. '     containing this program (GED2GENV.TXT)
  62. ' (7) Select File, Save As, GED2GENV.XLS to save this workbook & macro.
  63. '
  64. ' How to Use:
  65. ' (1) Open workbook GED2GENV.XLS containing this routine. It may
  66. '     behoove you to open it as Read Only to keep from bogarting it.
  67. '     This is especially true if you have Auto Save turned on.
  68. ' (2) Select File, New to open a new Workbook to receive the inbound
  69. '     GEDCOM records.
  70. ' (3) Select any sheet in the new workbook. Do not open any existing
  71. '     Excel workbook already containing any sheets named INDI, FAMI,
  72. '     HEAD, or SUBM. If you do so this routine will overwrite the data
  73. '     in these sheets.
  74. ' (4) Select Tools, Macro and select this routine, Select RUN.
  75. ' (5) Enter the path/name of your GEDCOM file.
  76. ' (6) Sit back and watch your spreadsheets fill with genealogy. On my
  77. '     Pentium system, it proceeds at 200 Individuals + 50 Families per
  78. '     minute from a Floppy drive.
  79. ' (7) Save your newly tabulated genealogy workbook. Generate tabular
  80. '     reports, make charts, ad-nauseum.
  81. '
  82. ' Limitations:
  83. ' (0) This will *NOT* work in Excel 4 or before. Excel Visual Basic
  84. '     doesn't exist until Excel 5.0a. I *don't* want to see 10,000
  85. '     "It Doesn't Work!" posts because you tried to use Excel 4 or
  86. '     earlier. Upgrade to Excel 5.0a - it's not that expensive. (It
  87. '     also puts Excel 4 to shame :-) :-) :-)
  88. '     - I also don't want to see 1,000 "Send Mac Version!" messages. I
  89. '     have never seen Mac Excel before. In fact, I learned MS Excel for
  90. '     the PC by slogging through the Help structure & gleaning what I
  91. '     could from the manuals. I imagine not much needs changing except
  92. '     perhaps the default file path & file name. If the Mac version
  93. '     doesn't yet support Visual Basic Macro Language then complain to
  94. '     Microsoft. They're the ones who left the Macs high & dry.
  95. '
  96. ' (1) MS Excel's Maximum Sheet Size limits us to 16,383 Individuals and
  97. '     16,383 Families. I have however used Long variables in order to be
  98. '     ready for the day when Excel (6? 7?) allows Unlimited Rows (or at
  99. '     least 2,147,483,647 rows). Lacking this, version 2 may allow
  100. '     multiple Individual and Family sheets. In this case, I1 thru I16000
  101. '     would be on INDI1, I16001 to 32000 on INDI2, and so on.
  102. '
  103. ' (2) Memory constraints may reduce this further. On a small machine
  104. '     Excel yielded up the ghost at around 10,000 persons (Out of Memory).
  105. '     A special version I am thinking about would use DDE calls to send
  106. '     incoming data along into MS Access.
  107. '
  108. ' (3) MS Excel can't handle dates prior to 1900. It forces them to
  109. '     character strings. If you try to force a negative Date Serial it
  110. '     fills the cell with overflow characters ("#").
  111. '
  112. ' Known Problems:
  113. ' (1) Case 18 under SayNoMore doesn't work yet. It's supposed to grab a
  114. '     pressed break key and ask the user if sie wants to continue but
  115. '     the system still grabs the break first. Same effect, but not as
  116. '     user-friendly as I would like. (Any System Error is User-Rude).
  117. '
  118. ' (2) The box asking for a file name will sometimes not indicate that
  119. '     the name entered was a nonexistent file. Instead it will end off
  120. '     or generate error 53. Again, same effect. Just re-RUN & give the
  121. '     correct name.
  122. '
  123. ' (3) Can't get dates prior to 1900 to format as dates. Excel 5.0a
  124. '     forces them to character strings. Any attempt to force a negative
  125. '     Date Serial Number causes a formatter error (all "#"s). I will
  126. '     write a special parse routine that will create a negative Date
  127. '     Serial Number and completely overlay that with a format string
  128. '     containing the original incoming date. That way Date Sorting will
  129. '     yield correct ordering.
  130. '
  131. ' (4) To Do List:
  132. '     - Write SUBM Interpreter.
  133. '     - Write Pre-1900 Date Serial Number Function
  134. '     - Include comment records as Cell Notes.
  135. ' ----------------------------------------
  136. Dim RECLEVEL As String
  137. Dim LastINDI As String, LastFAMI As String
  138. Dim LastHUSB As String, LastWIFE As String, LastCHIL As String
  139. Dim LastSUBM As String
  140. Dim ZeroMode As String, Level1Mode As String
  141. Dim Level2Mode As String, Level3Mode As String
  142. Dim IndiRow As Long, IndiScroll As Long
  143. Dim FamiRow As Long, FamiScroll As Long
  144. Dim ChildCol As Long
  145. Dim Gender As String
  146. Dim FNUM As Long, GEDREC As String, MoreRecords As Boolean
  147. Dim HeadSheet As Object, SubmSheet As Object
  148. Dim INDISheet As Object, FAMISheet As Object
  149. Dim NbrMales As Long, NbrFemales As Long, NbrBinnaums As Long
  150. Dim NbrChildren As Long, NbrFamilies As Long
  151. Dim CurrChild As Long, HighChild As Long
  152. '
  153. ' ImportGEDCOM
  154. '
  155. ' Asks for a GEDCOM file name, looks it up, loads it.
  156. '
  157. Sub ImportGEDCOM()
  158.   Dim FileOK As Boolean
  159.   Dim GEDFileName
  160.   GEDFileName = InputBox( _
  161.     Title:="GEDCOM to Excel 5.0a Worksheet Import Utility", _
  162.     prompt:="Please enter the name of the GEDCOM file:", _
  163.     default:="A:\warren.GED")
  164.   FileOK = FileExists(GEDFileName)
  165.   If FileOK Then
  166.     CreateHeading GEDFileName
  167.     ParseGEDCOM GEDFileName
  168.   Else
  169.     MsgBox "File " + GEDFileName + " Doesn't Exist.", _
  170.       vbExclamation
  171.   End If
  172. End Sub
  173. '
  174. ' FileExists
  175. '
  176. ' Looks up a file & traps the resulting errors.
  177. '
  178. Function FileExists(FILENAME) As Boolean
  179.   On Error GoTo CheckError
  180.   FileExists = (Dir(FILENAME) <> "")
  181.   Exit Function
  182. CheckError:
  183.   Dim Msg
  184.   FileExists = False
  185.   LastErrNum = Err
  186.   Select Case LastErrNum
  187.   Case 71 ' DiskNotReady
  188.     Msg = "Put a Floppy disk in the drive and close the drive door."
  189.     If MsgBox(Msg, vbExclamation + vbOKCancel) = vbOK Then
  190.       Resume
  191.     Else
  192.       Resume Next
  193.     End If
  194.   Case 68 ' Device Unavailable
  195.     Msg = "This drive:\path does not exist: " & FILENAME
  196.     MsgBox Msg, vbExclamation
  197.     Resume Next
  198.   Case Else
  199.     Msg = "Unexpected Error #" & Str(Err) & ": " & Error(Err)
  200.     MsgBox Msg, vbCritical
  201.     End ' Gracefully quit
  202.   End Select
  203. End Function
  204. ' CreateHeading
  205. '
  206. ' Sets up Genvelope Sheet's Headings.
  207. '
  208. Sub CreateHeading(FILENAME)
  209.   Set INDISheet = MayBuildSheet("INDI")
  210.   ActiveWindow.DisplayGridlines = True
  211.   Call MakeHeadingCell("A1", "Self")
  212.   Call MakeHeadingCell("B1", "Father")
  213.   Call MakeHeadingCell("C1", "Mother")
  214.   Call MakeHeadingCell("D1", "Sibling")
  215.   Call MakeHeadingCell("E1", "Offspring")
  216.   Call MakeHeadingCell("F1", "When Born")
  217.   Call MakeHeadingCell("G1", "When Died")
  218.   Call MakeHeadingCell("H1", "Sex")
  219.   Call MakeHeadingCell("I1", "Birth Surname")
  220.   Call MakeHeadingCell("J1", "Birth Given Names")
  221.   Call MakeHeadingCell("K1", "Title")
  222.   Call MakeHeadingCell("L1", "Birth Place")
  223.   Call MakeHeadingCell("M1", "Death Place")
  224.   ActiveWindow.DisplayGridlines = True
  225.   Sheets("INDI").Select
  226.   With ActiveSheet
  227.     .Columns("A:H").HorizontalAlignment = xlCenter
  228.     .Columns("F:G").NumberFormat = "dd mmm yyyy"
  229.     .Range("A1", "E1").Orientation = xlDownward
  230.     .Range("H1", "H1").Orientation = xlDownward
  231.     With .Rows("1:1")
  232.       .HorizontalAlignment = xlCenter
  233.       .VerticalAlignment = xlCenter
  234.       .WrapText = True
  235.       .RowHeight = 100
  236.       .EntireRow.AutoFit
  237.     End With
  238.     .Columns("I:M").ColumnWidth = 15
  239.     .Columns("A:M").EntireColumn.AutoFit
  240.   End With
  241.   Set FAMISheet = MayBuildSheet("FAMI")
  242.   Call MakeHeadingCell("A1", "Family")
  243.   Call MakeHeadingCell("B1", "Husband")
  244.   Call MakeHeadingCell("C1", "Wife")
  245.   Call MakeHeadingCell("D1", "When Married")
  246.   Call MakeHeadingCell("E1", "Where Married")
  247.   Call MakeHeadingCell("F1", "Divorce")
  248.   Call MakeHeadingCell("G1", "1st Child")
  249.   Call MakeHeadingCell("H1", "2nd Child")
  250.   Call MakeHeadingCell("I1", "3rd Child")
  251.   Call MakeHeadingCell("J1", "4th Child")
  252.   Call MakeHeadingCell("K1", "5th Child")
  253.   Call MakeHeadingCell("L1", "6th Child")
  254.   Call MakeHeadingCell("M1", "7th Child")
  255.   Call MakeHeadingCell("N1", "8th Child")
  256.   Call MakeHeadingCell("O1", "9th Child")
  257.   Call MakeHeadingCell("P1", "10th Child")
  258.   Call MakeHeadingCell("Q1", "11th Child")
  259.   Call MakeHeadingCell("R1", "12th Child")
  260.   ActiveWindow.DisplayGridlines = True
  261.   Sheets("FAMI").Select
  262.   With ActiveSheet
  263.     .Columns("A:Z").HorizontalAlignment = xlCenter
  264.     .Columns("E:E").HorizontalAlignment = xlLeft
  265.     .Columns("D:D").NumberFormat = "dd mmm yyyy"
  266.     .Columns("G:Z").ColumnWidth = 5
  267.     .Range("A1", "C1").Orientation = xlDownward
  268.     .Range("F1", "F1").Orientation = xlDownward
  269.     With .Rows("1:1")
  270.       .HorizontalAlignment = xlCenter
  271.       .VerticalAlignment = xlCenter
  272.       .WrapText = True
  273.       .RowHeight = 100
  274.       .EntireRow.AutoFit
  275.     End With
  276.     .Columns("A:Z").EntireColumn.AutoFit
  277.   End With
  278.   Set HeadSheet = MayBuildSheet("HEAD")
  279.   HeadSheet.Columns("A:A").ColumnWidth = 20
  280.   Call MakeHeadingCell("A1", "Source")
  281.   Call MakeHeadingCell("A2", "Database File")
  282.   Call MakeHeadingCell("A3", "Destination")
  283.   Call MakeHeadingCell("A4", "Gedcom File")
  284.   Call MakeHeadingCell("A5", "Gedcom Date")
  285.   Call MakeHeadingCell("A6", "Load Started")
  286.   Call MakeHeadingCell("A7", "Load Ended")
  287.   Call MakeHeadingCell("A8", "LOAD STATISTICS")
  288.   Call MakeHeadingCell("A9", "Persons")
  289.   Call MakeHeadingCell("A10", "Males")
  290.   Call MakeHeadingCell("A11", "Females")
  291.   Call MakeHeadingCell("A12", "Families")
  292.   Call MakeHeadingCell("A13", "Children")
  293.   Call MakeHeadingCell("A14", "Time to Load")
  294.   ActiveWindow.DisplayGridlines = True
  295.   Sheets("HEAD").Select
  296.   With ActiveSheet
  297.     .Range("B9:B13").Value = 0
  298.     .Range("C13:V13").Value = 0
  299.     .Range("A1:A7").HorizontalAlignment = xlRight
  300.     .Range("A9:A14").HorizontalAlignment = xlRight
  301.     .Range("B5:B6").NumberFormat = "dd-mmm-yyyy hh:mm:ss"
  302.     .Range("B7:B7").NumberFormat = "dd-mmm-yyyy hh:mm:ss"
  303.     .Range("B9:B13").NumberFormat = "#,##0"
  304.     .Range("B9:B14").HorizontalAlignment = xlLeft
  305.     .Range("B6").Value = Now
  306.     .Columns("A:B").ColumnWidth = 30
  307.     .Columns("A:B").EntireColumn.AutoFit
  308.     .Rows("1:16").EntireRow.AutoFit
  309.   End With
  310.   Set HeadSheet = MayBuildSheet("SUBM")
  311.   ActiveWindow.DisplayGridlines = True
  312. End Sub
  313. '
  314. ' Selects a sheet & Builds it if it doesn't exist
  315. '
  316. Function MayBuildSheet(Whatever As String) As Object
  317.   Dim ChosenSheet As Object
  318.   On Error GoTo NoSuchSheet
  319.   Sheets(Whatever).Select
  320.   Set ChosenSheet = Sheets(Whatever)
  321.   Set MayBuildSheet = ChosenSheet
  322.   On Error GoTo 0
  323.   Exit Function
  324. NoSuchSheet:
  325.   On Error GoTo 0
  326.   Set ChosenSheet = Sheets.Add
  327.   Set MayBuildSheet = ChosenSheet
  328.   With ChosenSheet
  329.     .Name = Whatever
  330.   End With
  331.   Sheets(Whatever).Select
  332. End Function
  333. '
  334. ' MakeHeadingCell
  335. '
  336. ' Edits the Cell Attributes to turn it into a Header Cell.
  337. '
  338. Sub MakeHeadingCell(CellID, Textstring)
  339.   Range(CellID).Select
  340.   ActiveCell.FormulaR1C1 = "^" + Textstring
  341.   With Selection.Font
  342.     .Name = "Arial"
  343.     .FontStyle = "Normal"
  344.     .Size = 8
  345.     .Strikethrough = False
  346.     .Superscript = False
  347.     .Subscript = False
  348.     .OutlineFont = False
  349.     .Shadow = False
  350.     .Underline = xlNone
  351.     .ColorIndex = xlAutomatic
  352.   End With
  353.   With Selection
  354.     .WrapText = True
  355.     .HorizontalAlignment = xlCenter
  356.     .VerticalAlignment = xlCenter
  357.     .Borders(xlLeft).LineStyle = xlSingle
  358.     .Borders(xlRight).LineStyle = xlSingle
  359.     .Borders(xlTop).LineStyle = xlSingle
  360.     .Borders(xlBottom).LineStyle = xlSingle
  361.     .BorderAround Weight:=xlThin, ColorIndex:=xlAutomatic
  362.     .EntireColumn.AutoFit
  363.   End With
  364. End Sub
  365. '
  366. ' ParseGEDCOM - Reads all GEDCOM records & passes these records
  367. '               along to the ParseRecord subroutine which reacts
  368. '               to their contents.
  369. '
  370. Sub ParseGEDCOM(FILENAME)
  371.   IndiRow = 1
  372.   FamiRow = 1
  373.   IndiScroll = 1
  374.   FamiScroll = 1
  375.   NbrMales = 0
  376.   NbrFemales = 0
  377.   NbrBinnaums = 0
  378.   FNUM = FreeFile()
  379.   Open FILENAME For Input Access Read As #FNUM
  380.   MoreRecords = True
  381.   On Error GoTo SayNoMore
  382.   Do
  383.     Line Input #FNUM, GEDREC
  384.     ParseRecord GEDREC
  385.     If Not MoreRecords Then Exit Do
  386.   Loop While MoreRecords
  387.   On Error GoTo 0
  388.   Close FNUM
  389.   Sheets("HEAD").Select
  390.   With ActiveSheet
  391.     .Range("B4").Value = FILENAME
  392.     .Range("B10").Value = NbrMales
  393.     .Range("B11").Value = NbrFemales
  394.     .Range("B9").Formula = NbrMales + NbrFemales + NbrBinnaums
  395.     .Range("B7").Value = Now
  396.     .Range("B14").Value = .Range("B7").Value - .Range("B6").Value
  397.     Select Case .Range("B14").Value
  398.     Case 0 To 1 / 1440
  399.       .Range("B14").NumberFormat = "ss"" sec"""
  400.     Case 1 / 1440 To 1 / 24
  401.       .Range("B14").NumberFormat = "mm ""min"" ss ""sec"""
  402.     Case Else
  403.       .Range("B14").NumberFormat = "[hh]:mm:ss"
  404.     End Select
  405.     .Range("B13").Value = NbrChildren
  406.     .Range("B12").Value = NbrFamilies
  407.     .Range("B1", "B7").HorizontalAlignment = xlLeft
  408.     Columns("B:V").EntireColumn.AutoFit
  409.   End With
  410.   Exit Sub
  411. SayNoMore:
  412.   lasterr = Err
  413.   Select Case lasterr
  414.   Case 18 ' User Pressed Break Key
  415.     If MsgBox("Stop Processing Records?", vbYesNo) = vbNo Then
  416.       Resume
  417.     Else
  418.       MoreRecords = False
  419.     End If
  420.   Case 62 ' End of File Reached
  421.     MoreRecords = False
  422.   Case Else ' Unexpected Error
  423.     MoreRecords = False
  424.     MsgBox Error(lasterr)
  425.   End Select
  426.   Resume Next
  427. End Sub
  428. '
  429. ' ParseRecord - Reacts to the contents of a GEDCOM Record and performs
  430. '               actions necessary to glean out field info & insert that
  431. '               info into the active sheet.
  432. '
  433. Sub ParseRecord(GEDREC As String)
  434.   Dim R As String
  435.   Dim LastName As String, FrstName As String, TitlName As String
  436.   Dim BirthDate As String, DeathDate As String, MarrDate As String
  437.   Dim MarrPlace As String, MarrStatus As String
  438.   On Error GoTo MajorBogosity
  439.   RECLEVEL = NToken(GEDREC, 1, " ")
  440.   Select Case RECLEVEL
  441.   Case "0"
  442.     ZeroMode = NToken(GEDREC, 3, " ")
  443.     If ZeroMode = "" Then ZeroMode = NToken(GEDREC, 2, " ")
  444.     If ZeroMode = "" Then ZeroMode = "HEAD"
  445.     If ZeroMode = "INDI" Then
  446.       LastINDI = NToken(GEDREC, 2, "@")
  447.       Sheets("INDI").Select
  448.       IndiRow = IndiRow + 1
  449.       If IndiRow > 10 Then
  450.         ActiveWindow.SmallScroll down:=1
  451.         ActiveWindow.LargeScroll toLeft:=1
  452.       End If
  453.       If IndiRow = 10 Or IndiRow = 20 Or (IndiRow Mod 50) = 0 Then
  454.         ActiveSheet.Columns("A:M").EntireColumn.AutoFit
  455.       End If
  456.       ActiveSheet.Cells(IndiRow, 1).Formula = LastINDI
  457.     ElseIf ZeroMode = "FAM" Then
  458.       LastFAMI = NToken(GEDREC, 2, "@")
  459.       If FamiRow = 1 Then
  460.         Sheets("INDI").Select
  461.         ActiveSheet.Columns("A:L").EntireColumn.AutoFit
  462.       End If
  463.       Sheets("FAMI").Select
  464.       FamiRow = FamiRow + 1
  465.       NbrFamilies = NbrFamilies + 1
  466.       If FamiRow > 10 Then
  467.         ActiveWindow.SmallScroll down:=1
  468.         ActiveWindow.LargeScroll toLeft:=1
  469.       End If
  470.       If FamiRow = 10 Or FamiRow = 20 Or (FamiRow Mod 50) = 0 Then
  471.         ActiveSheet.Columns("A:Z").EntireColumn.AutoFit
  472.       End If
  473.       ChildCol = 7
  474.       CurrChild = 0
  475.       ActiveSheet.Cells(FamiRow, 1).Formula = LastFAMI
  476.       LastHUSB = ""
  477.       LastWIFE = ""
  478.       LastCHIL = ""
  479.     ElseIf ZeroMode = "HEAD" Then
  480.       Sheets("HEAD").Select
  481.       Range("A2").Select
  482.     ElseIf ZeroMode = "SUBM" Then
  483.       Sheets("SUBM").Select
  484.       Range("A2").Select
  485.     ElseIf ZeroMode = "TRLR" Then
  486.       Sheets("FAMI").Select
  487.       Columns("A:Z").EntireColumn.AutoFit
  488.       Sheets("INDI").Select
  489.       Columns("A:M").EntireColumn.AutoFit
  490.     Else
  491.       ZeroMode = "none"
  492.     End If
  493.   Case "1"
  494.     If ZeroMode = "FAM" Then
  495.       Level1Mode = NToken(GEDREC, 2, " ")
  496.       If Level1Mode = "HUSB" Then
  497.         LastHUSB = NToken(GEDREC, 2, "@")
  498.         If LastHUSB <> "I0" And LastHUSB <> "0" Then
  499.           ActiveSheet.Cells(FamiRow, 2).Value = LastHUSB
  500.         End If
  501.       ElseIf Level1Mode = "WIFE" Then
  502.         LastWIFE = NToken(GEDREC, 2, "@")
  503.         If LastWIFE <> "I0" And LastWIFE <> "0" Then
  504.           ActiveSheet.Cells(FamiRow, 3).Value = LastWIFE
  505.         End If
  506.       ElseIf Level1Mode = "CHIL" Then
  507.         LastCHIL = NToken(GEDREC, 2, "@")
  508.         If LastCHIL <> "I0" And LastCHIL <> "0" Then
  509.           ActiveSheet.Cells(FamiRow, ChildCol).Value = LastCHIL
  510.           Link_Family
  511.           ChildCol = ChildCol + 1
  512.           CurrChild = CurrChild + 1
  513.           NbrChildren = NbrChildren + 1
  514.           If CurrChild > HighChild Then HighChild = CurrChild
  515.           With Sheets("HEAD")
  516.             With .Cells(13, CurrChild + 2)
  517.               .Value = .Value + 1
  518.             End With
  519.             .Cells(12, CurrChild + 2).Value = CurrChild
  520.           End With
  521.         End If
  522.       ElseIf Level1Mode = "MARR" Then
  523.       End If
  524.     ElseIf ZeroMode = "INDI" Then
  525.       Level1Mode = NToken(GEDREC, 2, " ")
  526.       If Level1Mode = "NAME" Then
  527.         R = Mid(GEDREC, 8)
  528.         LastName = NToken(R, 2, "/")
  529.         FrstName = NToken(R, 1, "/")
  530.         TitlName = NToken(R, 3, "/")
  531.         ActiveSheet.Cells(IndiRow, 9).Formula = LastName
  532.         ActiveSheet.Cells(IndiRow, 10).Formula = FrstName
  533.         ActiveSheet.Cells(IndiRow, 11).Formula = TitlName
  534.       ElseIf Level1Mode = "TITL" Then
  535.         R = Mid(GEDREC, 8)
  536.         TitlName = Trim(R)
  537.         ActiveSheet.Cells(IndiRow, 11).Formula = TitlName
  538.       ElseIf Level1Mode = "SEX" Then
  539.         R = Mid(GEDREC, 7)
  540.         Gender = NToken(R, 1, " ")
  541.         If Gender = "M" Then NbrMales = NbrMales + 1
  542.         If Gender = "F" Then NbrFemales = NbrFemales + 1
  543.         If Gender = "B" Then NbrBinnaums = NbrBinnaums + 1  ' :-) :-) :-)
  544.         ActiveSheet.Cells(IndiRow, 8).Formula = Gender
  545.       ElseIf Level1Mode = "BIRT" Then
  546.       ElseIf Level1Mode = "BAPM" Then
  547.       ElseIf Level1Mode = "DEAT" Then
  548.       ElseIf Level1Mode = "BURI" Then
  549.       End If
  550.     ElseIf ZeroMode = "HEAD" Then
  551.       Level1Mode = NToken(GEDREC, 2, " ")
  552.       Debug.Print GEDREC
  553.       If Level1Mode = "SOUR" Then
  554.         R = Mid(GEDREC, 7)
  555.         ActiveSheet.Cells(1, 2).Value = Trim(R)
  556.       ElseIf Level1Mode = "DEST" Then
  557.         R = Mid(GEDREC, 7)
  558.         ActiveSheet.Cells(3, 2).Value = Trim(R)
  559.       ElseIf Level1Mode = "DATE" Then
  560.         R = Mid(GEDREC, 7)
  561.         With ActiveSheet.Cells(5, 2)
  562.           .NumberFormat = "dd mmm yyyy"
  563.           .Formula = Trim(R)
  564.         End With
  565.       ElseIf Level1Mode = "FILE" Then
  566.         R = Mid(GEDREC, 7)
  567.         ActiveSheet.Cells(2, 2).Value = Trim(R)
  568.       End If
  569.     ElseIf ZeroMode = "SUBM" Then
  570.       Level1Mode = NToken(GEDREC, 2, " ")
  571.       R = Mid(GEDREC, 7)
  572.       LastSUBM = NToken(GEDREC, 2, "@")
  573.     End If
  574.   Case "2"
  575.     Level2Mode = NToken(GEDREC, 2, " ")
  576.     R = Mid(GEDREC, 4 + Len(Level2Mode))
  577.     If ZeroMode = "INDI" Then
  578.       If Level1Mode = "BIRT" Then
  579.         If Level2Mode = "DATE" Then
  580.           BirthDate = Trim(R)
  581.           With ActiveSheet.Cells(IndiRow, 6)
  582.             If IsNumeric(BirthDate) Then
  583.               .NumberFormat = """ABT ""yyyy"
  584.               .Value = CDate("1/1/" & BirthDate)
  585.             Else
  586.               .NumberFormat = "dd mmm yyyy"
  587.               .Value = BirthDate
  588.             End If
  589.           End With
  590.         ElseIf Level2Mode = "PLAC" Then
  591.           BirthPlace = Trim(R)
  592.           ActiveSheet.Cells(IndiRow, 12).Value = BirthPlace
  593.         End If
  594.       ElseIf Level1Mode = "DEAT" Then
  595.         If Level2Mode = "DATE" Then
  596.           DeathDate = Trim(R)
  597.           With ActiveSheet.Cells(IndiRow, 7)
  598.             If IsNumeric(DeathDate) Then
  599.               .NumberFormat = """ABT ""yyyy"
  600.               .Value = CDate("1/1/" & DeathDate)
  601.             Else
  602.               .NumberFormat = "dd mmm yyyy"
  603.               .Value = DeathDate
  604.             End If
  605.           End With
  606.         ElseIf Level2Mode = "PLAC" Then
  607.           DeathPlace = Trim(R)
  608.           ActiveSheet.Cells(IndiRow, 13).Value = DeathPlace
  609.         End If
  610.       End If
  611.     ElseIf ZeroMode = "FAM" Then
  612.       If Level1Mode = "MARR" Then
  613.         If Level2Mode = "DATE" Then
  614.           MarrDate = Trim(R)
  615.           With ActiveSheet.Cells(FamiRow, 4)
  616.             If IsNumeric(MarrDate) Then
  617.               .NumberFormat = """ABT ""yyyy"
  618.               .Value = CDate("1/1/" & MarrDate)
  619.             Else
  620.               .NumberFormat = "dd mmm yyyy"
  621.               .Value = MarrDate
  622.             End If
  623.           End With
  624.         ElseIf Level2Mode = "PLAC" Then
  625.           MarrPlace = Trim(R)
  626.           ActiveSheet.Cells(FamiRow, 5).Value = MarrPlace
  627.         ElseIf Level2Mode = "DIV" Then
  628.           MarrStatus = Trim(R)
  629.           ActiveSheet.Cells(FamiRow, 6).Value = MarrStatus
  630.         End If
  631.       End If
  632.     End If
  633.   Case Else
  634.   End Select
  635.   Exit Sub
  636. MajorBogosity:
  637.   lasterr = Err
  638.   lasterrln = errl
  639.   With Sheets("HEAD")
  640.     .Cells(27, 1).Value = lasterr
  641.     .Cells(28, 1).Value = lasterrln
  642.     .Cells(29, 1).Value = Error(lasterr)
  643.     .Cells(30, 1).Value = GEDREC
  644.   End With
  645.   Resume Next
  646. End Sub
  647. '
  648. ' Link_Families - Sweeps down FAMI & builds up the Father, Mother,
  649. '                 Sibling, and Offspring linkages.
  650. '
  651. '   Called during FAMI import when a CHILd is encountered.
  652. '
  653. Sub Link_Family()
  654.   Dim FathrRow As Long, MothrRow As Long
  655.   Dim ChildRow As Long
  656.   Dim Sibling As String, SiblingRow As Long
  657.   Dim Offspring As String, OffspringRow As Long
  658.   Dim InsertingSibling As Boolean
  659.   With INDISheet.Columns("A:A")
  660.     ChildRow = .Find(LastCHIL).Row
  661.     FathrRow = .Find(LastHUSB).Row
  662.     MothrRow = .Find(LastWIFE).Row
  663.   End With
  664.   If FathrRow <> 0 Then
  665.     With INDISheet.Cells(ChildRow, 2)
  666.       If .Value = "" Then .Value = LastHUSB
  667.     End With
  668.     With INDISheet.Cells(FathrRow, 5)
  669.       If .Value = "" Then .Value = LastCHIL
  670.     End With
  671.     With INDISheet
  672.       InsertingSibling = True
  673.       Offspring = .Cells(FathrRow, 5).Value
  674.       If Offspring = LastCHIL Then InsertingSibling = False
  675.       OffspringRow = .Columns("A:A").Find(Offspring).Row
  676.       If OffspringRow = 0 Then InsertingSibling = False
  677.       Do While InsertingSibling
  678.         Sibling = .Cells(OffspringRow, 4).Value
  679.         If Sibling = "" Then
  680.           .Cells(OffspringRow, 4).Value = LastCHIL
  681.           Exit Do
  682.         End If
  683.         If Sibling = LastCHIL Then Exit Do
  684.         Offspring = Sibling
  685.         OffspringRow = .Columns("A:A").Find(Offspring).Row
  686.         If OffspringRow = 0 Then Exit Do
  687.       Loop
  688.     End With
  689.   End If
  690.   If MothrRow <> 0 Then
  691.     With INDISheet.Cells(ChildRow, 3)
  692.       If .Value = "" Then .Value = LastWIFE
  693.     End With
  694.     With INDISheet.Cells(MothrRow, 5)
  695.       If .Value = "" Then .Value = LastCHIL
  696.     End With
  697.     With INDISheet
  698.       InsertingSibling = True
  699.       Offspring = .Cells(MothrRow, 5).Value
  700.       If Offspring = LastCHIL Then InsertingSibling = False
  701.       OffspringRow = .Columns("A:A").Find(Offspring).Row
  702.       If OffspringRow = 0 Then InsertingSibling = False
  703.       Do While InsertingSibling
  704.         Sibling = .Cells(OffspringRow, 4).Value
  705.         If Sibling = "" Then
  706.           .Cells(OffspringRow, 4).Value = LastCHIL
  707.           Exit Do
  708.         End If
  709.         If Sibling = LastCHIL Then Exit Do
  710.         Offspring = Sibling
  711.         OffspringRow = .Columns("A:A").Find(Offspring).Row
  712.         If OffspringRow = 0 Then Exit Do
  713.       Loop
  714.     End With
  715.   End If
  716. End Sub
  717. '
  718. ' NToken - returns the nth token in a delimited string.
  719. ' - What:   The string to be parsed for tokens
  720. ' - Which:  The token number to look for
  721. ' - Delims: The set of token delimiters
  722. '   Example: S=NToken("1 NAME Tom /Thacker/",2,"/") returns "Thacker".
  723. '
  724. Function NToken(What As String, _
  725.                 Which As Integer, _
  726.                 Delims As String) As String
  727.   Dim Work As String
  728.   Dim I As Integer, Hits As Integer
  729.   Dim Before As Integer, After As Integer
  730.   Work = Trim(What) + Delims ' Ensure that last token gets gotten
  731.   For I = 1 To Len(Work)
  732.     If POS(Delims, Mid(Work, I, 1)) <> 0 Then
  733.       Hits = Hits + 1
  734.       If Hits = (Which - 1) Then Before = I
  735.       If Hits = Which Then After = I
  736.     End If
  737.   Next I
  738.   NToken = ""
  739.   If Before = 0 And After = 0 Then Exit Function
  740.   If (After - Before) < 2 Then Exit Function
  741.   NToken = Mid(Work, Before + 1, After - Before - 1)
  742. End Function
  743. '
  744. ' POS takes the place of the missing string POS function
  745. '     found in every Basic on Earth EXCEPT MS EXCEL BASIC.
  746. '
  747. Function POS(Target As String, _
  748.              Source As String) As Integer
  749.   Dim I As Integer, TargLen As Integer, SrcLen As Integer
  750.   TargLen = Len(Target)
  751.   SrcLen = Len(Source)
  752.   For I = 1 To TargLen - SrcLen + 1
  753.     If Mid(Target, I, SrcLen) = Source Then
  754.       POS = I
  755.       Exit Function
  756.     End If
  757.   Next I
  758.   POS = 0
  759. End Function
  760.